#! /usr/bin/perl -W
use strict;

#
# command line processing
#

my @ignore;
while (scalar @ARGV) {
  $_ = shift @ARGV;
  if (/^-i(.*)$/) {
    push @ignore, $1;
  } else {
    die "unknown argument '$_'\n";
  }
}

#
# pass zero
#

my %out;

for (0..16) {
  my $n = $_; # sprintf("%02d", $_);
  my $t = "(";
  $t .= "cell, " for 1..$_ - 1;
  $t .= $_ ? "cell" : "void";
  $t .= "))tos)(";
  for (my $i = $_; $i-- > 1;) {
    $t .= "*(sp - $i), ";
  }
  $t .= "*sp" if $_;
  $t .= ");";
  $t .= " sp -= $_;" if $_;
  $out{"(c$n)"} = "tos = ((cell(*)$t";
}

#
# first pass
#

my (%asso, %consts, @source);
while (<>) { main: {
  next if /---/;
  last if /===/;
  if (/^\s+(\S+)\s+:\s+(.*$)/) {
    for my $ign (@ignore) {
      next main if /^\s+$ign/;
    }
    $out{my $n = $1} = $2;
    $out{$n} .= <> while $out{$n} =~ s/\\$//;
  } elsif (/ constant: (\S+)\s+(.*)$/) {
    $consts{$1} = "$2";
  } else {
    push @source, $_;
  }
} }

#
# second pass
#

my $wc = 0;
my @outkeys = sort keys %out;
my $predef = "enum {\n  x0 = 1,\n";
$predef .= " x$_,\n" for 1..$#outkeys;
$predef .= " xq};\n";
push @source, <<EOT;
static void *retr = `retr ;

static void
execute_ (void **ip)
{
  *--rp = (cell)&retr; /* stop mark on return stack */
/*   goto next;
drop:
    tos = *sp--;
next: */
    while (1) switch ((cell)*ip++)
    {
      case 0:
        ip = (void **)*rp++;
/*        goto next; */
        break;
EOT
my $init_dict = "dict_t init_dict[] = {\n";
for (@outkeys) {
  my $tmp = $_;
  $tmp =~ s/[*]\//*_\//g;
  $asso{my $name = $_} = $wc;
  my $class = $name =~ s/\`$// ? "!execute" : "?execute";
  $init_dict .= "  { NULL, \"$name\", (void *)x$wc, `$class },\n";
  my $break = 1;
#  $out{$_} =~ s/\$drop\s*$/goto drop;/ and $break = 0;
  while ($out{$_} =~ s/\$(\S+)/defined $out{$1}
                      ? $out{$1} : die "not defined $1"/e) {}
  push @source, "      case x$wc /* $tmp */:\n";
  if (0) { # $_ eq "drop") {
    push @source, "         goto drop;\n";
  } else {
    push @source, "         $out{$_}\n";
#    push @source, "         goto next;\n" if $break;
    push @source, "         break;\n" if $break;
  }
  $wc++;
}
push @source, <<EOT;
      default:
        *--rp = (cell)ip;
        ip = *(ip-1);
/*        goto next; */
    }
}

static void
execute2 (void **p)
{
      static void *tp[2];
      tp[0] = p;
      tp[1] = 0;
      execute_(tp);
}

static void
execute (void **p)
{
    if (!((cell(*)(cell))execute_hook)((cell)p))
    {
      static void *tp[2];
      tp[0] = p;
      tp[1] = 0;
      execute_(tp);
    }
}
EOT
my $numprims = $wc + 1;
my $cinit = "";
for (sort keys %consts) {
  my $tmp = $_;
  $tmp =~ s/[*]\//*_\//g;
  $cinit .= "  init_dict[$wc /* $tmp */].tok = (void*)(cell)($consts{$_});\n";
  $asso{$_} = $wc++;
  $init_dict .= " { NULL, \"$_\", NULL, `?literal },\n";
}
$init_dict .= "  { NULL, NULL, NULL, NULL }\n};\n\n";

#
# third pass
#

for (@source, $init_dict, <>) {
  s/\/\*PREDEF\*\/\s+/$predef\n#define PRIMITIVES $numprims\n/;
  s/\/\*CINIT\*\/\s+/$cinit/;
  die "needs `$1 ()\n" if / \`(\S+)\s*\(\s*\)/;
  s/ \`(\S+)/ (void *) x$asso{$1} \/* $1 *\//g;
  s/ \^\^(\S+)/ \&init_dict[$asso{$1}] \/* $1 *\//g;
  print $_;
}
